home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / amiga / modlibsr.zoo / $dbcmpl.P < prev    next >
Text File  |  1989-05-30  |  18KB  |  544 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona,1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24.  
  25.  
  26. /* This file contains Prolog predicates that compiles a clause into a 
  27. buffer. It treats all rules as though they had a single literal on the
  28. right-hand-side. Thus it compiles a clause with more than one literal
  29. on the right-hand-side as a call to the predicate ,/2 */
  30.  
  31. $dbcmpl_export([$db_cmpl/5,$db_cmpl/6,$db_putbuffop/4,$db_putbuffbyte/4,
  32.     $db_putbuffnum/4]).
  33.  
  34. /* $dbcmpl_use($buff,
  35.     [$alloc_perm/2,$alloc_heap/2,$trimbuff/3,$buff_code/4,$symtype/2,
  36.         $substring/6,$subnumber/6,$subdelim/6,$conlength/2,
  37.         $pred_undefined/1, $hashval/3]).
  38.    $dbcmpl_use($bmeta,[$atom/1,$atomic/1,$integer/1,$number/1,$structure/1,
  39.     $functor0/2,$bldstr/3,$arg/3,$arity/2,$real/1,$float/1,_,_]).
  40.    $db_use($bio,[$writename/1,$writeqname/1,$put/1,$nl/0,$tab/1,
  41.     $tell/1,$tell/2,$telling/1,$told/0,$get/1,$get0/1,$see/1,$seeing/1,
  42.     $seen/0]).
  43. */
  44.  
  45. $db_putbuffop(Opn,Buff,Li,Lo) :- 
  46.     $buff_code(Buff,Li,3 /*pb*/ ,Opn), Lo is Li+1.
  47.  
  48. $db_putbuffope(Opn,Buff,Li,Lo) :- 
  49.     $buff_code(Buff,Li,3 /*pb*/ ,Opn), Li1 is Li+1,
  50.     $buff_code(Buff,Li1,3 /*pb*/ ,0), Lo is Li1+1.
  51.  
  52. $db_putbuffbyte(Num,Buff,Li,Lo) :- 
  53.     $buff_code(Buff,Li,3 /*pb*/ ,Num), Lo is Li+1.
  54.  
  55. $db_putbuffnum(Num,Buff,Li,Lo) :- 
  56.     $buff_code(Buff,Li,2 /*pn*/ ,Num), Lo is Li+4.
  57.  
  58. $db_putbuffloat(Num,Buff,Li,Lo) :- 
  59.     $buff_code(Buff,Li,27 /*pf*/ ,Num), Lo is Li+4.
  60.  
  61. $db_putbuffptr(Num,Buff,Li,Lo) :- 
  62.     $buff_code(Buff,Li,1 /*pppsc*/ ,Num), Lo is Li+4.
  63.  
  64. $db_putbuffpsc(Num,Buff,Li,Lo) :- 
  65.     $buff_code(Buff,Li,0 /*ppsc*/ ,Num), Lo is Li+4.
  66.  
  67.  
  68. /* $db_cmpl(Clause,Clref,Index,Where,Supbuff): where Clause is a fact or
  69. rule. Clref is a variable through which is returned the Clref, and 
  70. Index is the argument to index on (0 if none). Where is 0 if the 
  71. buffer is to be allocated from the permanent area, and 2 if from a
  72. superbuff, which is in Supbuff. */
  73.  
  74. /* change in representation: previously, the asserted code for the clause
  75.    began at disp. 10 in the buffer.  I've changed it so the clause/3 can
  76.    be run backwards (i.e. given the DB reference, find the clause) without
  77.    too much trouble.  Now, bytes 10-11 contain a "noop 2" instruction,
  78.    which cause it to skip over the next 4 bytes (bytes 12-15), to byte 16,
  79.    where the asserted code really begins.  Bytes 12-15 contain a pointer
  80.    to the PSC entry of the predicate of the clause, so that its predicate
  81.    symbol and arity can be reconstructed easily by clause/3.
  82.                    - Saumya Debray, Aug 2 1988        */
  83.  
  84.  
  85. $db_cmpl(Clause,Buff,Index,Where,Supbuff) :- 
  86.     $db_cmpl(Clause,Buff,Index,Where,Supbuff,1).
  87.  
  88. $db_cmpl(Clause,Buff,Index,Where,Supbuff,Flatten) :- 
  89.     $alloc_buff(5000,Buff,Where,Supbuff,_),    /* must return Buff */
  90.     ((Clause ?= (_:-_) -> Clause=(Head:-Body); Clause=Head, Body=true),
  91.      $arity(Head,Arity),
  92.      Tempreg is Arity+1, 
  93.      $buff_code(Buff,0,14 /*ptv*/ ,Buff), /*set back pointer*/
  94.      $buff_code(Buff, 10, 3, 249 /* noop */),
  95.      $buff_code(Buff, 11, 3, 2),
  96.      $db_putbuffpsc(Head, Buff, 12, _),
  97.      $db_gentop(Head,Arity,1,Tempreg,Freereg,Buff,16,Lhd,uniq),
  98.      (Flatten =:= 1 ->
  99.          ($db_flatten(Body,FBody,[],Unifs),
  100.          $db_flcode(Unifs,Freereg,R0,Buff,Lhd,Lm0,uniq)
  101.         ) ;
  102.         (Body = FBody, R0 = Freereg, Lm0 = Lhd)
  103.      ),
  104.      $arity(FBody,Barity),
  105.      $db_genbod(FBody,Barity,1,[],Mvl,R0,Maxreg,Buff,Lm0,Lm1,uniq),
  106.      (Index > 0 -> $db_putbuffchain(Buff, Lm1, Length);
  107.                 Length = Lm1),
  108.      (Length > 5000,!,$db_mfail('Asserted clause too long ',Length);
  109.       Length =< 5000,
  110.        (Maxreg > 255,!,
  111.          $db_mfail('Assert: too many registers required ',Maxreg);
  112.         Maxreg =< 255,
  113.          $trimbuff(Length,Buff,Where,Supbuff),fail
  114.        )
  115.      )
  116.     ;
  117.      true
  118.     ).
  119.  
  120.  
  121. $db_mfail(Msg,Val) :- 
  122.     $telling(F),$tell(user),
  123.     $writename(Msg),$writename(Val),$nl,
  124.     $tell(F),fail.
  125.  
  126. $db_putbuffchain(Buff, Lin, Lout) :-
  127.         /* put code at the end for chaining clauses in the same bucket  */
  128.     $db_putbuffop(249 /* noop */, Buff, Lin, L1),
  129.         $db_putbuffbyte(2, Buff, L1, L2),
  130.         $db_putbuffnum(0, Buff, L2, L3),
  131.         $db_putbuffope(240 /* jump */, Buff, L3, L4),
  132.         $buff_code(Buff, 10, 4, EPADDR), /* get start address of the code*/
  133.         $db_putbuffnum(EPADDR, Buff, L4, Lout).
  134.  
  135. $db_gentop(Fact,Arity,Argno,Ri,Ro,Buff,Li,Lo,U) :- 
  136.     Argno > Arity,
  137.      Ri = Ro, Li=Lo
  138.     ;
  139.     Argno =< Arity, arg(Argno,Fact,T),
  140.      $db_gentopinst(T,Argno,Ri,Rm,Buff,Li,Lm,U),
  141.      Argno1 is Argno + 1,
  142.      $db_gentop(Fact,Arity,Argno1,Rm,Ro,Buff,Lm,Lo,U).
  143.  
  144. $db_gentopinst(T,Argno,Ri,Ro,Buff,Li,Lo,U) :-
  145.     var(T), T='$var'(Argno,U), Ri = Ro, Li = Lo 
  146.     ;
  147.     nonvar(T),
  148.      ($atom(T) ->
  149.        ((T ?= [] ->
  150.          ($db_putbuffop(5,Buff,Li,Li1),    /* getnil(Argno) */
  151.           $db_putbuffbyte(Argno,Buff,Li1,Lo)
  152.            ) ;
  153.          ($db_putbuffop(4,Buff,Li,Li1),    /* getcon(T,Argno) */
  154.              $db_putbuffbyte(Argno,Buff,Li1,Li2),
  155.              $db_putbuffptr(T,Buff,Li2,Lo)
  156.            )
  157.         ),
  158.         Ri = Ro
  159.        ) ;
  160.        (integer(T) ->             /* getnumcon(T,Argno) */
  161.         ($db_putbuffop(14,Buff,Li,Li1),
  162.          $db_putbuffbyte(Argno,Buff,Li1,Li2),
  163.          $db_putbuffnum(T,Buff,Li2,Lo),
  164.          Ri = Ro
  165.         ) ;
  166.         (real(T) ->             /* getfloatcon(T,Argno) */
  167.             ($db_putbuffop(32,Buff,Li,Li1),
  168.              $db_putbuffbyte(Argno,Buff,Li1,Li2),
  169.              $db_putbuffloat(T,Buff,Li2,Lo),
  170.              Ri = Ro
  171.             ) ;
  172.             ((T='$var'(Rt,Un), nonvar(Un), Un=U ) ->
  173.                      /* gettval(Rt,Argno) */
  174.                 ($db_putbuffope(3,Buff,Li,Li1),
  175.                    $db_putbuffbyte(Rt,Buff,Li1,Li2),
  176.                    $db_putbuffbyte(Argno,Buff,Li2,Lo),
  177.                    Ri = Ro
  178.                 ) ;
  179.                 $db_genterms([Argno,T],Ri,Ro,Buff,Li,Lo,U)
  180.             )
  181.             )
  182.         )
  183.      ).
  184.  
  185. $db_genterms([],R,R,_,L,L,_).
  186. $db_genterms([R,T|Ts],Ri,Ro,Buff,Li,Lo,U) :-
  187.     $db_genstruc(T,R,Buff,Ri,Rm,Li,Lm2,Substrs,U),
  188.     $db_genterms(Substrs,Rm,Rm2,Buff,Lm2,Lm3,U),
  189.     $db_genterms(Ts,Rm2,Ro,Buff,Lm3,Lo,U).
  190.  
  191. $db_genstruc((A1,A2),R,Buff,Ri,Ro,Li,Lo,[],U) :-
  192.     var(A1),var(A2),not(A1==A2),!,A1 = '$var'(Ri,U),
  193.     Rm1 is Ri+1, A2 = '$var'(Rm1,U), Ro is Rm1+1,
  194.     /* generate a getcomma_tvar_tvar */
  195.     $db_putbuffop(74,Buff,Li,Lm1),
  196.     $db_putbuffbyte(R,Buff,Lm1,Lm2),
  197.     $db_putbuffbyte(Ri,Buff,Lm2,Lm3),
  198.     $db_putbuffbyte(Rm1,Buff,Lm3,Lo).
  199.  
  200. $db_genstruc([A1|A2],R,Buff,Ri,Ro,Li,Lo,[],U) :-
  201.     var(A1),var(A2),not(A1==A2),!,A1 = '$var'(Ri,U),
  202.     Rm1 is Ri+1, A2 = '$var'(Rm1,U), Ro is Rm1+1,
  203.     /* generate a getlist_tvar_tvar */
  204.     $db_putbuffop(72,Buff,Li,Lm1),
  205.     $db_putbuffbyte(R,Buff,Lm1,Lm2),
  206.     $db_putbuffbyte(Ri,Buff,Lm2,Lm3),
  207.     $db_putbuffbyte(Rm1,Buff,Lm3,Lo).
  208.  
  209. $db_genstruc(T,R,Buff,Ri,Rm,Li,Lo,Substrs,U) :-
  210.     $db_genget(T,R,Buff,Li,Lm1),$arity(T,Arity),
  211.     $db_dosubs(T,0,Arity,Ri,Rm,Buff,Lm1,Lo,Substrs,[],U).
  212.  
  213.  
  214. $db_genget([_|_],R,Buff,Li,Lo) :- !,
  215.     /* getlist(R) */
  216.     $db_putbuffop(7,Buff,Li,Li1),
  217.     $db_putbuffbyte(R,Buff,Li1,Lo).
  218. $db_genget((_,_),R,Buff,Li,Lo) :- /* not(T=[_|_]) */ !,
  219.     /* getcomma(R) */
  220.     $db_putbuffop(73,Buff,Li,Li1),
  221.     $db_putbuffbyte(R,Buff,Li1,Lo).
  222. $db_genget(T,R,Buff,Li,Lo) :- /* not(T=(_,_)),not(T=[_|_]) */
  223.     /* functor(T,F,Arity), getstr((F,Arity),R) */
  224.     $db_putbuffop(6,Buff,Li,Li1),
  225.     $db_putbuffbyte(R,Buff,Li1,Li2),
  226.     $db_putbuffpsc(T,Buff,Li2,Lo).
  227.  
  228. $db_dosubs(T,I,Arity,Ri,Ro,Buff,Li,Lo,Si,So,U) :-
  229.     I < Arity, I1 is I+1, arg(I1,T,Sub),
  230.      $db_geninst(Sub,Ri,Rm,Si,Sm,Buff,Li,Lm,U),
  231.      $db_dosubs(T,I1,Arity,Rm,Ro,Buff,Lm,Lo,Sm,So,U)
  232.     ;
  233.     I >= Arity,        /* just to avoid having to lay down a CP */
  234.      I = Arity,Ri = Ro,Li = Lo,Si = So.
  235.  
  236. $db_geninst(Sub,Ri,Ro,Si,So,Buff,Li,Lo,U) :-
  237.     var(Sub), Si = So,
  238.       Ro is Ri+1, Sub='$var'(Ri,U),     /* unitvar(Ri) */
  239.       $db_putbuffop(10,Buff,Li,Li1),
  240.       $db_putbuffbyte(Ri,Buff,Li1,Lo)
  241.      ;
  242.       nonvar(Sub),
  243.          ($atom(Sub) ->
  244.             ((Sub ?= [] -> 
  245.                  $db_putbuffope(13,Buff,Li,Lo) ;    /* uninil */
  246.                  ($db_putbuffope(12,Buff,Li,Li1),  /* unicon(Sub) */
  247.               $db_putbuffptr(Sub,Buff,Li1,Lo))
  248.          ),
  249.           Ri = Ro, Si = So) ;
  250.         (integer(Sub) ->               /* uninumcon(Sub) */
  251.               ($db_putbuffope(30,Buff,Li,Li1),
  252.                $db_putbuffnum(Sub,Buff,Li1,Lo),
  253.                Ri = Ro, Si = So) ;
  254.                (real(Sub) ->               /* unifloatcon(Sub) */
  255.                       ($db_putbuffope(34,Buff,Li,Li1),
  256.                         $db_putbuffloat(Sub,Buff,Li1,Lo),
  257.                      Ri = Ro, Si = So) ;
  258.                      ((Sub='$var'(R,Un),nonvar(Un),Un=U) ->
  259.                             /* unitval(R) */
  260.                     ($db_putbuffop(11,Buff,Li,Li1),
  261.                       $db_putbuffbyte(R,Buff,Li1,Lo),
  262.                       Ri = Ro, Si = So) ;
  263.                     (Ro is Ri+1,        /* unitvar(Ri) */
  264.                       Si = [Ri,Sub|So],
  265.                       $db_putbuffop(10,Buff,Li,Li1),
  266.                       $db_putbuffbyte(Ri,Buff,Li1,Lo))
  267.                        )
  268.             )
  269.         )
  270.          ).
  271.  
  272. $db_genbod(true,0,1,Mvlst,Mvlst,R,R,Buff,Li,Lo,U) :- !,
  273.     $db_putbuffope(235 /*proceed*/ ,Buff,Li,Lo).
  274. $db_genbod(Body,Arity,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U) :-
  275.     $db_genbo1(Body,Arity,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U).
  276.  
  277. $db_genbo1(Body,Arity,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U) :-
  278.     Argno > Arity ->
  279.      Mvlst=Mvlsto,
  280.      $db_genmvs(Mvlst,Ri,Ro,Buff,Locin,Lm1),
  281.      functor(Body,Bodyn,Arity), /* wnl(execute(Bodyn,Arity)), */
  282.      $db_putbuffope(236,Buff,Lm1,Lm2),
  283.      $db_putbuffpsc(Body,Buff,Lm2,Locout)
  284.     ;
  285.      arg(Argno,Body,T),
  286.      $db_genaput(T,Argno,Mvlst,Mvlstm,Ri,Rm,Buff,Locin,Locm,U),
  287.      Argno1 is Argno+1,
  288.      $db_genbo1(Body,Arity,Argno1,Mvlstm,Mvlsto,Rm,Ro,Buff,Locm,Locout,U).
  289.  
  290. $db_genaput(T,Argno,Mvlst,Mvlsto,Ri,Ro,Buff,Locin,Locout,U) :-
  291.     var(T) ->
  292.      Ro is Ri+1,Locout=Locin,Mvlsto=[puttvar(Tempvar),Argno|Mvlst],
  293.      T='$var'(Tempvar,U)
  294.     ;
  295.      (T='$var'(Rt,U) ->
  296.        (var(Rt) -> Mvlsto=[puttvar(Rt),Argno|Mvlst];
  297.                Mvlsto=[movreg(Rt),Argno|Mvlst]),
  298.        Ro=Ri,Locout=Locin
  299.       ;
  300.        (integer(T) ->
  301.          Mvlsto=[putnumcon(T),Argno|Mvlst],Ro=Ri,Locout=Locin
  302.         ;
  303.          (real(T) ->
  304.            (Mvlsto=[putfloatcon(T),Argno|Mvlst],Ro=Ri,Locout=Locin)
  305.           ;
  306.           ($atom(T) ->
  307.         (T ?= [] -> Mvlsto=[putnil,Argno|Mvlst];
  308.              Mvlsto=[putcon(T),Argno|Mvlst]),
  309.         Ro=Ri,Locout=Locin
  310.           ;
  311.         Mvlsto=[movreg(Ri),Argno|Mvlst],Rm is Ri+1,
  312.             $db_putterm(Ri,T,Rm,Ro,Buff,Locin,Locout,U)
  313.          )
  314.        )
  315.      )
  316.     ).
  317.  
  318. $db_putterm(R,T,Ri,Ro,Buff,Li,Lo,U) :-
  319.     $arity(T,Arity),
  320.     $db_putsubstr(T,0,Arity,Ri,Rm,Buff,Li,Lm1,[],Subterms,U),
  321.     $db_genputstr(T,R,Buff,Lm1,Lm2),
  322.     $db_putsubs(Subterms,Rm,Ro,Buff,Lm2,Lo).
  323.  
  324. $db_genputstr([_|_],R,Buff,Li,Lo) :- !,
  325.     /* wnl(putlist(R)), */
  326.     $db_putbuffop(23,Buff,Li,Li1),
  327.     $db_putbuffbyte(R,Buff,Li1,Lo).
  328. /* $db_genputstr((_,_),R,Buff,Li,Lo) :- * not(T=[_|_]) * !,
  329.      * getcomma(R) *
  330.     $db_putbuffop(73,Buff,Li,Li1),
  331.     $db_putbuffbyte(R,Buff,Li1,Lo). */
  332. $db_genputstr(T,R,Buff,Li,Lo) :- /* not(T=(_,_)),not(T=[_|_]) */
  333.     /* functor(T,F,Arity), wnl(putstr((F,Arity),R)), */
  334.     $db_putbuffop(22,Buff,Li,Li1),
  335.     $db_putbuffbyte(R,Buff,Li1,Li2),
  336.     $db_putbuffpsc(T,Buff,Li2,Lo).
  337.  
  338. $db_putsubstr(T,I,Arity,Ri,Ro,Buff,Li,Lo,Si,So,U) :-
  339.     I < Arity -> I1 is I+1, arg(I1,T,Sub),
  340.      $db_bldsubs(Sub,Ri,Rm,Si,Sm,Buff,Li,Lm,U),
  341.      $db_putsubstr(T,I1,Arity,Rm,Ro,Buff,Lm,Lo,Sm,So,U)
  342.     ;
  343.      I = Arity,Ri = Ro,Li = Lo,Si = So.
  344.  
  345. $db_bldsubs(Sub,Ri,Ro,Si,So,Buff,Li,Lo,U) :-
  346.     var(Sub) -> So = [bldtvar(Ri)|Si],
  347.       Ro is Ri+1, Li = Lo, Sub='$var'(Ri,U)     /* bldtvar(Ri) */
  348.      ;
  349.       ($atom(Sub) ->
  350.          (Sub ?= [] -> So = [bldnil|Si];    /* bldnil */
  351.             So = [bldcon(Sub)|Si]), /* bldcon(Sub) */
  352.          Ri = Ro, Li = Lo
  353.         ;
  354.          (integer(Sub) ->               /* bldnumcon(Sub) */
  355.         So = [bldnumcon(Sub)|Si], Ri = Ro, Li = Lo
  356.           ;
  357.             (real(Sub) ->               /* bldfloatcon(Sub) */
  358.            (So = [bldfloatcon(Sub)|Si], Ri = Ro, Li = Lo) ;
  359.            ((Sub='$var'(R,Un),nonvar(Un),Un=U) ->
  360.               So = [bldtval(R)|Si],    /* bldtval(R) */
  361.               Ri = Ro,Li = Lo
  362.              ;
  363.               Rm is Ri+1,        /* bldtvar(Ri) */
  364.               So = [bldtval(Ri)|Si], 
  365.               $db_putterm(Ri,Sub,Rm,Ro,Buff,Li,Lo,U)
  366.           ) 
  367.         )
  368.          )
  369.       ).
  370.  
  371. $db_putsubs([],R,R,_,L,L).
  372. $db_putsubs([Bld|Rest],Ri,Ro,Buff,Li,Lo) :-
  373.     $db_putsubs(Rest,Ri,Ro,Buff,Li,Lm),
  374.     $db_bldinst(Bld,Buff,Lm,Lo).
  375.  
  376. :- mode($db_bldinst,4,[c,d,d,d]).
  377.  
  378. $db_bldinst(bldtvar(R),Buff,Li,Lo) :-
  379.     /* wnl(bldtvar(R)), */
  380.     $db_putbuffop(26,Buff,Li,Li1),
  381.     $db_putbuffbyte(R,Buff,Li1,Lo).
  382. $db_bldinst(bldnil,Buff,Li,Lo) :-
  383.     /* wnl(bldnil), */
  384.     $db_putbuffope(29,Buff,Li,Lo).
  385. $db_bldinst(bldcon(Sub),Buff,Li,Lo) :-
  386.     /* wnl(bldcon(Sub)), */
  387.     $db_putbuffope(28,Buff,Li,Li1),
  388.     $db_putbuffptr(Sub,Buff,Li1,Lo).
  389. $db_bldinst(bldnumcon(Sub),Buff,Li,Lo) :-
  390.     /* wnl(bldnumcon(Sub)), */
  391.     $db_putbuffope(31,Buff,Li,Li1),
  392.     $db_putbuffnum(Sub,Buff,Li1,Lo).
  393. $db_bldinst(bldfloatcon(Sub),Buff,Li,Lo) :-
  394.     /* wnl(bldfloatcon(Sub)), */
  395.     $db_putbuffope(35,Buff,Li,Li1),
  396.     $db_putbuffloat(Sub,Buff,Li1,Lo).
  397. $db_bldinst(bldtval(R),Buff,Li,Lo) :-
  398.     /* wnl(bldtval(R)), */
  399.     $db_putbuffop(27,Buff,Li,Li1),
  400.     $db_putbuffbyte(R,Buff,Li1,Lo).
  401.  
  402.  
  403. /* this is a simple routine to generate  a series  of instructions to
  404. load a series of  registers with  constants or  from other registers.
  405. It is  given a  list of  Source,Target pairs.   Target  is always a
  406. register  number.  Source may be a putcon(con), putnumcon(num), putfloatcon(num),
  407. puttvar(reg),  puttvar(Var),  or  movreg(reg).    The  registers  can
  408. overlap in any way.  $db_genmvs tries to generate  a reasonably efficient
  409. series  of  instructions  to  load  the indicated  registers with the
  410. indicated values.  */ 
  411.  
  412. $db_genmvs([],R,R,B,L,L).
  413. $db_genmvs([I,T|Rest],Ri,Ro,Buff,Li,Lo) :- $db_genmvs(I,T,Ri,Ro,Buff,Li,Lo,Rest).
  414.  
  415. :- mode($db_genmvs,8,[c,c,d,d,d,d,d,d]).
  416.  
  417. $db_genmvs(puttvar(R),T,Ri,Ro,Buff,Li,Lo,Rest) :-
  418.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  419.     (nonvar(R) -> 
  420.         /* wnl(movreg(R,T)), */
  421.         $db_putbuffope(209,Buff,Lm,Lm1),
  422.         $db_putbuffbyte(R,Buff,Lm1,Lm2),
  423.         $db_putbuffbyte(T,Buff,Lm2,Lo)
  424.       ;
  425.         R=T, /* wnl(puttvar(R,R)), */
  426.         $db_putbuffope(18,Buff,Lm,Lm1),
  427.         $db_putbuffbyte(R,Buff,Lm1,Lm2),
  428.         $db_putbuffbyte(R,Buff,Lm2,Lo)
  429.     ).
  430.  
  431. $db_genmvs(putcon(C),T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  432.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  433.     /* wnl(putcon(T,C)), */
  434.     $db_putbuffop(20,Buff,Lm,Lm1),
  435.     $db_putbuffbyte(T,Buff,Lm1,Lm2),
  436.     $db_putbuffptr(C,Buff,Lm2,Lo).
  437.  
  438. $db_genmvs(putnil,T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  439.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  440.     /* wnl(putnil(T)), */
  441.     $db_putbuffop(21,Buff,Lm,Lm1),
  442.     $db_putbuffbyte(T,Buff,Lm1,Lo).
  443.  
  444. $db_genmvs(putnumcon(I),T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  445.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  446.     /* wnl(putnumcon(T,I)), */
  447.     $db_putbuffop(15,Buff,Lm,Lm1),
  448.     $db_putbuffbyte(T,Buff,Lm1,Lm2),
  449.     $db_putbuffnum(I,Buff,Lm2,Lo).
  450.  
  451. $db_genmvs(putfloatcon(I),T,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  452.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  453.     /* wnl(putfloatcon(T,I)), */
  454.     $db_putbuffop(33,Buff,Lm,Lm1),
  455.     $db_putbuffbyte(T,Buff,Lm1,Lm2),
  456.     $db_putbuffloat(I,Buff,Lm2,Lo).
  457.  
  458. $db_genmvs(movreg(R),R,Ri,Ro,Buff,Li,Lo,Rest) :- !,
  459.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lo).
  460.  
  461. $db_genmvs(movreg(S),T,Ri,Ro,Buff,Li,Lo,Rest) :- not($dbcmpl_frstmem(T,Rest)),!,
  462.     /* wnl(movreg(S,T)), */
  463.     $db_putbuffope(209,Buff,Li,Lm1),
  464.     $db_putbuffbyte(S,Buff,Lm1,Lm2),
  465.     $db_putbuffbyte(T,Buff,Lm2,Lm),
  466.     $db_genmvs(Rest,Ri,Ro,Buff,Lm,Lo).
  467.  
  468. $db_genmvs(movreg(S),T,Ri,Ro,Buff,Li,Lo,Rest) :- not($dbcmpl_scndmem(S,Rest)),!,
  469.     $db_genmvs(Rest,Ri,Ro,Buff,Li,Lm),
  470.     /* wnl(movreg(S,T)), */
  471.     $db_putbuffope(209,Buff,Lm,Lm1),
  472.     $db_putbuffbyte(S,Buff,Lm1,Lm2),
  473.     $db_putbuffbyte(T,Buff,Lm2,Lo).
  474.  
  475. $db_genmvs(movreg(S),T,Ri,Ro,Buff,Li,Lo,Rest) :- 
  476.     /* wnl(movreg(S,Ri)), */
  477.     $db_putbuffope(209,Buff,Li,Lm1),
  478.     $db_putbuffbyte(S,Buff,Lm1,Lm2),
  479.     $db_putbuffbyte(Ri,Buff,Lm2,Lm3),
  480.     Rm is Ri+1,
  481.     $db_genmvs(Rest,Rm,Ro,Buff,Lm3,Lm4),
  482.     /* wnl(movreg(Ri,T)), */
  483.     $db_putbuffope(209,Buff,Lm4,Lm5),
  484.     $db_putbuffbyte(Ri,Buff,Lm5,Lm6),
  485.     $db_putbuffbyte(T,Buff,Lm6,Lo).
  486.  
  487.  
  488. /* wnl(X) :- write(X),nl. */
  489.  
  490.  
  491. $dbcmpl_frstmem(T,[movreg(T),_|_]).
  492. $dbcmpl_frstmem(T,[_|Rest]) :- $dbcmpl_frstmem(T,Rest).
  493.  
  494.  
  495. $dbcmpl_scndmem(S,[_,S|_]).
  496. $dbcmpl_scndmem(S,[_|Rest]) :- $dbcmpl_scndmem(S,Rest).
  497.  
  498. /*  This is a kludge to fix up a problem with the depth-first
  499.     traversal of arguments interacting in a bad way with the
  500.     flattening of terms.  The problem is that when translating
  501.     arguments in the body, the depth first traversal doesn't take
  502.     into account the fact that subterms may move forward due to
  503.     flattening, thereby changing "first" and "subsequent"
  504.     occurrences of variables.  To make things work, though much
  505.     less efficiently than before, I'm just going through an
  506.     explicit flattening stage beforehand.  I don't doubt there
  507.     are more elegant solutions, I'm just a user who wants to
  508.     use assert to do other things.                */
  509.  
  510. $db_flatten(Term,NewTerm,Si,So) :-
  511.     $structure(Term) ->
  512.         (functor(Term,F,N),
  513.          functor(NewTerm,F,N),
  514.          $db_flatten1(Term,0,N,NewTerm,Si,So)
  515.         );
  516.         (NewTerm = Term, Si = So).
  517.  
  518. $db_flatten1(Term,N,Arity,NewTerm,Si,So) :-
  519.     (N =:= Arity) ->
  520.         (Si = So) ;
  521.         (ArgNo is N + 1,
  522.          arg(ArgNo,Term,OldArg),
  523.          arg(ArgNo,NewTerm,NewArg),
  524.          (($structure(OldArg), OldArg \= '$var'(_,_)) ->
  525.                    /* nested structure, needs flattening */
  526.              (Sm0 = [NewArg,NewArg0|Si],
  527.              $db_flatten(OldArg,NewArg0,Sm0,Sm1)
  528.             ) ;
  529.             (OldArg = NewArg, Sm1 = Si)
  530.          ),
  531.          N1 is N + 1,
  532.          $db_flatten1(Term,N1,Arity,NewTerm,Sm1,So)
  533.         ).
  534.  
  535. $db_flcode([],R,R,_Buff,Loc,Loc,_).
  536. $db_flcode([Temp,Str|Rest],Ri,Ro,Buff,Li,Lo,U) :-
  537.     Temp = '$var'(R,U),
  538.     ((var(R), R = Ri, Rm0 is Ri+1) ;
  539.      (nonvar(R), Rm0 = Ri)
  540.     ),
  541.     $db_putterm(R,Str,Rm0,Rm1,Buff,Li,Lm,U),
  542.     $db_flcode(Rest,Rm1,Ro,Buff,Lm,Lo,U).
  543.  
  544.